perm filename PLTCMD.OLD[MSS,LCS] blob
sn#127299 filedate 1974-10-25 generic text, type T, neo UTF8
00100 C**** PLTCMD, FILLMS, ROTATE ********
00200 SUBROUTINE PLTCMD
00300 CC IMPLICIT INTEGER(A-Q,S-Z)
00400 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
00500 DIMENSION NMS(8),RMOV1(8),RMOV2(8)
00600 COMMON /DL/X22,SAVER,NAME /ALF/INP(3),ML
00700 COMMON RJB,JE,CENTR,JB,RJQ(20),JQ(20)
00800 EQUIVALENCE (RJE,RJQ(3)),(RJF,RJQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
00900 1,(RJC,RJQ(1)),(I2,INP(2)),(RJH,RJQ(6)),(I3,INP(3))
01000 F78F(1)='(78F)'
01100 FA5(1)='(A5) '
01200 FA1(1)='(A1) '
01300
01400 IF(I2.NE.'X')GO TO 1
01500 CC ML=' '
01600 I2=0
01700 RXC=0
01800 RMOV1(1)='Y'
01900 NAME=0
02000 14 KA=0
02100 3 KA=KA+1
02200 CC IF(ML.EQ.' ')GO TO 15
02300 IF(ML.EQ.0)GO TO 15
02400 K=K-2
02500 ML=ML-1
02600 IF(ML.EQ.0)GO TO 10
02700 GO TO 31
02800 15 TYPE 2,KA
02900 ACCEPT 11,K,ML
03000 C TYPE LAST NAME, NUMBER FOR A SERIES
03100 50 IF(K.EQ.' ')GO TO 10
03200 IF(K.EQ.'99')GO TO 140
03300 C 99=BACKUP
03400 31 IF(LOOKD(K))GO TO 56
03500 C JUMP IF FILE FOUND
03600 TYPE 55
03700 GO TO 15
03800 55 FORMAT(' FILE NOT FOUND'/)
03900 11 FORMAT(A5,I)
04000 56 NMS(KA)=K
04100 CC IF(ML.EQ.' ')GO TO 5
04200 IF(ML.EQ.0)GO TO 5
04300 RJH='Y'
04400 GO TO 21
04500 5 TYPE 8
04600 ACCEPT FA5,RJH
04700 IF(RJH.EQ.'99')GO TO 15
04800 IF(RJH.NE.'Y')RJH=0
04900 IF(RJH.EQ.0)REREAD F78F,RJH
05000 C MOVE NUMBER CAN BE TYPED FOR 'MOVE UP'
05100 21 RMOV1(KA+1)=RJH
05200 RMOV2(KA)=RJH
05300 GO TO 3
05400 140 KA=KA-1
05500 GO TO 15
05600
05700 10 KB=KA-1
05800 IF(I3.NE.'G')GO TO 22
05900 RSIZ=1
06000 GO TO 222
06100 22 TYPE 9
06200 ACCEPT F78F,RSIZ
06300 IF(RSIZ.EQ.99.OR.RSIZ.EQ.0)GO TO 5
06400 222 KA=0
06500
06600 1 IF(NAME.NE.0)GO TO 12
06700 IF(KA.EQ.KB)GO TO 100
06750 C EXITB IS FOR FR80 RELEASE ****************
06800 NAME=NMS(KA+1)
06900 TYPE 111,NAME
07000 RETURN
07100 12 KA=KA+1
07200 NAME=0
07300 CC RJD=1
07400 CC IF(INP(3).EQ.'C')RJD=0
07450 RJD=0
07500 C 'PXC' = CALCOMP OUTPUT
07600 RJH=0
07700 RJB=RSIZ
07800 RJC=RSIZ
07900 RJG=0
08000 RJE=1
08100 RJF=1
08200 IF(RMOV2(KA).NE.'Y')RJG=RMOV2(KA)
08300 IF(RMOV1(KA).NE.0)RJE=0
08310 IF(RMOV2(KA).NE.0.OR.RJG.NE.0)RJF=0
08350 RETURN
08375 100 TYPE 101
08380 ACCEPT 11,K
08385 IF(K.EQ.'Y')CALL EXITB
08390 CALL EXIT
08395 101 FORMAT(' FOR FR80?? -- '$)
08500 2 FORMAT(' TYPE FILE NAME',I2,1X$)
08600 8 FORMAT(' MOVE UP AT END? ',$)
08700 9 FORMAT(' SIZE FACTOR? ',$)
08800 111 FORMAT(1XA5/)
08900 END
25460
25500 C****** CHANGE 3, 4 AND 5 TO JFCL IN DDT WHEN USING DISTORTION.(SEE 'LINES')
25600 SUBROUTINE FILLMS(L,IDAT,RJB,CENTR,RJF,RJG)
25700 COMMON/DL/IXRX,SAVER,NAME
25800 COMMON/DST/BB,CC/FLM/X(200),Y(200),NX(200)
25900 DIMENSION IDAT(1)
26000 COMMON/PLTR/IPLT,RHT,DIS/LL/LL/STF/RR(8),RSTJC
26100 DATA MP/2/,MD/6/
26200 C MD=DISPLAY MP=PLOTTER MX=XGP
26300 DX=DIS
26400 RX=RHT
26500 D=RSTJC*RJF
26600 R=RSTJC*RJG
26700 4 GO TO 1
26800 C=CC
26900 B=BB
27000 C SAVES IT. IT WILL RETURN LATER.
27100 BB=B/DIS
27200 CC=1000
27300 1 KK=0
27400 DO 205 J=1,L
27500 CALL UNPACK(M,N,IDAT(J))
27600 KK=KK+1
27700 NX(KK)=0
27800 IF(LL.EQ.3)NX(KK)=3
27900 X(KK)=ROFF((RJB+D*M)*DIS)
28000 Y(KK)=ROFF((CENTR+R*N)*RHT)
28100 3 GO TO 205
28200 Y(KK)=Y(KK)*(C-BB*(ABS(X(KK))))
28300 C FOR DISTORTION
28400 205 CONTINUE
28500 NX(1)=KK
28600 DIS=1.0
28700 RHT=DIS
28800 M=MD
28900 IF(IPLT)M=MP-IXRX
29000 C STOPS DISTORTION IN 'LINES'
29100 2 CALL FILLER(X,Y,NX,M)
29200 DIS=DX
29300 RHT=RX
29400 5 RETURN
29500 C NEXT TO RESET DISTORTION FACT.
29600 BB=B
29700 CC=C
29800 RETURN
29900 END
30000
30100 SUBROUTINE ROTATE(I,L,DEG)
30200 DIMENSION I(1)
30300 N=I(L)
30400 KNT=501
30500 C ROTATED DATA IS PUT BACK STARTING AT LOCATION 501.
30600 I(KNT)=N
30700 DO 1 K=L+1,N+L-1
30800 CALL UNPACK(J,M,I(K))
30900 X=J
31000 Y=M
31100 JJ=I(K)/100000000
31200 AX=ATAN2(X,Y)*57.29578
31300 HYP=SQRT(X**2+Y**2)
31400 ROT=DEG+AX
31500 J=ROFF(HYP*COSD(ROT))
31600 M=ROFF(HYP*SIND(ROT))
31700 KNT=KNT+1
31800 IF(J)J=1000-J
31900 IF(M)M=1000-M
32000 1 I(KNT)=M*10000+J+JJ*100000000
32100 L=501
32200 END